home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vscode23.arc / VSCODE23.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1991-03-01  |  10.0 KB  |  336 lines
  1.       {***************************************************************}
  2.       {*                                                             *}
  3.       {*                    C O D E R  2.3                           *}
  4.       {*                                                             *}
  5.       {*             reserved files encoder                          *}
  6.       {*                  (English version)                          *}
  7.       {*  ---------------------------------------------------------  *}
  8.       {*           for informations please refer to:                 *}
  9.       {*                                                             *}
  10.       {*                     LUCA MANUNTA                            *}
  11.       {*                Via Ignazio Ciampi 14                        *}
  12.       {*                00162         ROMA                           *}
  13.       {*                         ITALY        tel.06/8600384         *}
  14.       {*                                                             *}
  15.       {*  ---------------------------------------------------------  *}
  16.       {*                copyright by MANUSOFT '89                    *}
  17.       {***************************************************************}
  18.  
  19.  
  20. type
  21.   daco=char;
  22.  
  23. var
  24.   error,pw,key,line,x,y,a,b,c,d,ncod,lun:integer;
  25.   codif,concordi,cond1,cond2:boolean;
  26.   flg1,flg2,flg3:boolean;
  27.   cripto:string[5];
  28.   answ3,chiave,dom:string[20];
  29.   answ1,answ2:string[12];
  30.   answ,codato,contr,dacod:char;
  31.   destfil,nomefil:file of daco;
  32.  
  33.  
  34. OVERLAY PROCEDURE help;   {-------------------------------------------------------}
  35.  
  36.   PROCEDURE screen;
  37.   begin
  38.     clrscr;
  39.     for a:=1 to 80 do write('*');
  40.     for a:=1 to 80 do
  41.        begin
  42.          gotoxy(a,24);write('*');
  43.        end;
  44.  
  45.      gotoxy(10,25);write('<ESC> back to Main menu                          *manusoft ''89*');
  46.      textbackground(7);textcolor(0);
  47.      gotoxy(30,5);
  48.      write(' C O D E R  2.3 ');
  49.      textbackground(0);textcolor(15);
  50.    end;
  51.  
  52. begin
  53.    screen;
  54.    gotoxy(2,7);writeln('    The program "CODER", in his brand new version 2.3, allows you to protect');
  55.    writeln(' your reserved files, of any kind and length. This protection can be reached  ');
  56.    writeln(' through an impenetrable algoritm of encryption which works on the base of a ');
  57.    writeln(' key directly given by the user. It is therefore plain that wether this key is');
  58.    writeln(' not known it isn''t also possible to decrypt the coded file.');
  59.    writeln;writeln;
  60.    writeln;write('   The program is divided into three main sections:');
  61.    writeln;
  62.    write(' Two of them are strictly operative, the third (this shown) is overlayed not to occupy uselessly memory');
  63.    write(' space. ');
  64.    writeln;writeln;
  65.    write('(press any key to have more specific informations)');
  66.    read(kbd,answ);
  67.    if(ord(answ)=27) then exit;
  68.  
  69.    screen;
  70.    gotoxy(5,7);writeln('SEZ.CRITTOGRAFAZIONE:');
  71.    writeln(' The prompt will ask you to input the name of the file to be encrypted and the ');
  72.    writeln(' encryption key to be used. In output the program will give back a file with ');
  73.    writeln(' same name of source file but having .COD extension.  This parameter cannot be');
  74.    writeln(' modified by the user.  Source file will be automatically deleted.');
  75.    writeln;writeln;
  76.    writeln('SEZ. DECRITTOGRAFAZIONE:');
  77.    writeln(' The prompt will ask you to input the name of the file to be uncrypted and the ');
  78.    writeln(' decryptation key used for encryption of that file - always rember the specific');
  79.    writeln(' encryption key used for each file as there will be no other way to restore the');
  80.    writeln(' file in his original form and you will loose all data.');
  81.    writeln(' In output the program will give back the original file, with same name but ');
  82.    writeln(' .DOC extension (this means that when you decrypt any executable file you ');
  83.    writeln(' will have to change "manually" its extension in .COM or .EXE to execute it');
  84.    writeln(' from MS-DOS. The coded file will be automatically deleted.');
  85.    repeat until keypressed;
  86. end;
  87.  
  88. PROCEDURE schermo;   {------------------------------------------------------}
  89. begin
  90.   clrscr;
  91.   for a:=1 to 80 do write('*');
  92.   for a:=1 to 80 do
  93.     begin
  94.       gotoxy(a,24);write('*');
  95.     end;
  96.   for y:=1 to 23 do
  97.     begin
  98.       x:=1;
  99.       gotoxy(x,y);write('*');
  100.       x:=80;
  101.       gotoxy(x,y);write('*');
  102.     end;
  103.   gotoxy(10,25);write('<ESC> to exit                                        *manusoft ''89*');
  104. end;
  105.  
  106.  
  107. PROCEDURE leggidati;     {------------------------------------------------------}
  108. begin
  109. gotoxy(25,13);write('File name to be ',dom);
  110.    read(kbd,contr);
  111.    a:=ord(contr);
  112.    if (a=27) then
  113.    begin
  114.      flg3:=true;
  115.      exit;
  116.    end;
  117.    gotoxy(30,16);write(contr);read(answ1);
  118.    answ1:=contr+answ1;
  119.    gotoxy(25,13);write('                                           ');
  120.    gotoxy(25,16);write('                                     ');
  121.    gotoxy(25,13);write('Input encryption key...');
  122.    gotoxy(30,16);read(answ3);
  123. end;
  124.  
  125. PROCEDURE errorcheck;    {------------------------------------------------------}
  126.   begin
  127.     error:=IOresult;
  128.     while (error<>0) do
  129.       begin
  130.       if (error=1) then
  131.          begin
  132.            clrscr;
  133.            writeln('ERROR OCCURRED:');
  134.            writeln('The file to be encrypted (',answ1,') doesn''t exists at specified address');
  135.            writeln;writeln('press any key');
  136.            repeat
  137.            until keypressed;
  138.            flg1:=true;
  139.          end;
  140.       if (error=241) then
  141.          begin
  142.            clrscr;
  143.            writeln('ERROR OCCURRED:');
  144.            writeln('Destination disk is full.');
  145.            writeln('Please change disk and press any key or <ESC> to exit');
  146.            read(kbd,answ);
  147.            if (answ=chr(27)) then flg2:=true;
  148.            flg1:=true;
  149.          end;
  150.       if (error<>1) and (error<>241) then
  151.          begin
  152.            clrscr;
  153.            writeln('ERROR OCCURRED:');
  154.            writeln('Error n.',error,' verified during encryption file process ');
  155.            writeln('Please verify program or call a technic.');
  156.            flg2:=true;
  157.         end;
  158.       error:=0;
  159.     end;
  160.   end;
  161.  
  162. PROCEDURE destcheck;     {------------------------------------------------------}
  163.   begin
  164.     {$i-} reset(destfil) {$i+};
  165.           if (IOresult=0) then
  166.              begin
  167.                clrscr;
  168.                writeln('WARNING : file already exists');
  169.                writeln('          Overwrite it? (y/n) ');
  170.                read(kbd,answ);
  171.                case answ of
  172.                  'Y','y':exit;
  173.                  'n','N':flg1:=true;
  174.                  else destcheck;
  175.                end;
  176.              end;
  177.   end;
  178.  
  179. PROCEDURE apertura;      {------------------------------------------------------}
  180. begin
  181.   assign(nomefil,answ1);
  182.   assign(destfil,answ2);
  183.   chiave:=answ3;
  184.   lun:=length(chiave);
  185.   a:=0;
  186.   b:=0;
  187.   c:=0;
  188.   flg1:=false;
  189.   flg2:=false;
  190.   cripto:='';
  191.  
  192.         {$i-} reset(nomefil) {$i+};
  193.               errorcheck;
  194.               if flg1 or flg2 then exit;
  195.               destcheck;
  196.               if flg1 or flg2 then exit;
  197.               rewrite(destfil);
  198.               clrscr;
  199. end;
  200.  
  201. PROCEDURE working;       {------------------------------------------------------}
  202. begin
  203.   case d of
  204.      50: begin
  205.            gotoxy(30,12);
  206.            write('O  O  O  O  O  O');
  207.          end;
  208.      100: begin
  209.            gotoxy(30,12);
  210.            write(' O  O  O  O  O  ');
  211.          end;
  212.      150: begin
  213.            d:=0;
  214.            gotoxy(30,12);
  215.            write('  O  O  O  O  O  ');
  216.          end;
  217.    end;
  218. end;
  219.  
  220.  
  221. PROCEDURE ciclolavoro;    {---------------------------------------------------}
  222. begin
  223.  
  224.   gotoxy(35,10);
  225.   textbackground(7);textcolor(0);
  226.   write('WORKING');
  227.   textbackground(0);textcolor(15);
  228.  
  229.   for a:=1 to filesize(nomefil) do
  230.     begin
  231.       d:=d+1;
  232.       read(nomefil,dacod);
  233.       b:=0;
  234.       pw:=ord(dacod);
  235.       c:=c+1;if (c>lun) then c:=1;
  236.       key:=ord(copy(chiave,c,1));
  237.  
  238.       working;
  239.  
  240.       if codif then
  241.          begin
  242.            ncod:=pw+sqr(key);
  243.            if (ncod>255) then ncod:=ncod-256;
  244.          end;
  245.       if not codif then
  246.          begin
  247.            ncod:=pw-sqr(key);
  248.            if (ncod<0) then ncod:=ncod+256;
  249.          end;
  250.       codato:=chr(ncod);
  251.       write(destfil,codato);
  252.     end;
  253.  
  254.   close(nomefil);
  255.   close(destfil);
  256.   erase(nomefil);
  257.  
  258.   clrscr;
  259.   gotoxy(20,10);writeln('Successfull encryption, destination file: ',answ2);
  260.   writeln;writeln('(Press any key)');
  261.   repeat until keypressed;
  262. end;
  263.  
  264. PROCEDURE critto;   {-----------------------------------------------------}
  265.   begin
  266.     schermo;
  267.     gotoxy(25,5);write('ENCRYPTION :');
  268.     dom:='encrypt?';
  269.     leggidati;
  270.     if flg3 then exit;
  271.     answ2:=copy(answ1,1,pos('.',answ1))+'cod';
  272.     apertura;
  273.     if flg1 or flg2 then exit;
  274.     codif:=true;
  275.     ciclolavoro;
  276.   end;
  277.  
  278. PROCEDURE decritto;   {______________________________________________________}
  279. begin
  280.   schermo;
  281.   gotoxy(25,5);write('UNCRYPTION :');
  282.   dom:='uncrypt?';
  283.   leggidati;
  284.   if flg3 then exit;
  285.   answ2:=copy(answ1,1,pos('.',answ1))+'doc';
  286.   apertura;
  287.   if flg1 or flg2 then exit;
  288.   codif:=false;
  289.   ciclolavoro;
  290. end;
  291.  
  292.  
  293.  
  294. PROCEDURE mainopz;   {--------------------------------------------------------}
  295. begin
  296.    flg3:=false;
  297.    schermo;
  298.  
  299.    textbackground(7);textcolor(0);
  300.    gotoxy(32,5);
  301.    write(' C O D E R  2.3 ');
  302.    textbackground(0);textcolor(15);
  303.  
  304.    gotoxy(35,6);write('---------');
  305.    gotoxy(25,7);write('Reserved files encryption');
  306.    gotoxy(25,8);write('--------------------------------');
  307.    gotoxy(27,12);write('1) Encryption');
  308.    gotoxy(27,14);write('2) Uncryption');
  309.    gotoxy(27,16);write('3) Help');
  310.    read(kbd,answ);
  311.    if (ord(answ)=27) then exit;
  312.  
  313.    case answ of
  314.     '1': critto;
  315.     '2': decritto;
  316.     '3': help;
  317.    end;
  318.  
  319.    if flg2 then exit;
  320.    mainopz;
  321. end;
  322.  
  323.  {--------------  HERE BEGINS PROGRAM MAIN LOOP  -----------------}
  324.  
  325. begin
  326.   flg1:=false;
  327.   flg2:=false;
  328.   error:=0;
  329.   mainopz;
  330.  
  331.   clrscr;
  332.   gotoxy(20,10);
  333.   exit;
  334.  
  335. end.
  336.